home *** CD-ROM | disk | FTP | other *** search
/ Hyper Stacks 1994 May / Hyper Stacks (Pacific HiTech)(1994)[Mac].iso / XCMDS&XFCNS / HCScrapUtils / SaveScrap.Pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-07-14  |  2.2 KB  |  101 lines  |  [TEXT/MPS ]
  1. Program SaveScrap;
  2. {
  3.     This module produces a HyperCard XCMD resource to save the
  4.     current contents of the Clipboard as a resource with the
  5.     given type and ID in the current stack.  If a resource
  6.     already exists with the same type and ID, it is deleted.
  7.     Call the XCMD from HyperCard as follows:
  8.  
  9.     saveScrap resType, resID
  10.  
  11.     Written by Lawrence D'Oliveiro 1988 January 13.
  12.     Last modified 1988 July 14.
  13. }
  14. {$C 'XCMD' 128 'SaveScrap' 32}
  15. {$H 'XCmdHeader'}
  16. {$T 'XCMD'}
  17.  
  18.     Uses
  19.     MacIntf,
  20.     HyperXCmd;
  21.  
  22.     Procedure TheProc
  23.       (
  24.     ParamPtr : XCmdPtr
  25.       );
  26.       { actual code for the XCMD. }
  27.  
  28.     Var
  29.         TheResType : ResType;
  30.         TheResID : Integer;
  31.         TheScrap : PScrapStuff;
  32.         WasOnDisk : Boolean;
  33.         TheResource : Handle;
  34.         Err : OSErr;
  35.  
  36.     Procedure GetResTypeAndID;
  37.       { get resource type and ID. }
  38.  
  39.         Var
  40.         ResIDString : Str255;
  41.  
  42.       Begin
  43.         BlockMove(ParamPtr^.Params[1]^, @TheResType, 4);
  44.         ZeroToPas(ParamPtr, ParamPtr^.Params[2]^, ResIDString);
  45.         TheResID := StrToNum(ParamPtr, ResIDString)
  46.       End {GetResTypeAndID};
  47.  
  48.     Procedure ReturnError
  49.       (
  50.         Error : Integer
  51.       );
  52.       { return error number as a string. }
  53.  
  54.         Var
  55.         ErrorString : Str255;
  56.  
  57.       Begin
  58.         NumToString(Error, ErrorString);
  59.         ParamPtr^.ReturnValue := PasToZero(ParamPtr, ErrorString)
  60.       End {ReturnError};
  61.  
  62.       Begin {TheProc}
  63.     GetResTypeAndID;
  64.       { ensure no duplicate resources }
  65.     TheResource := Get1Resource(TheResType, TheResID);
  66.     If TheResource <> Nil then
  67.         RmveResource(TheResource);
  68.     TheScrap := InfoScrap;
  69.     Err := NoErr;
  70.     WasOnDisk := TheScrap^.ScrapState = 0;
  71.     If WasOnDisk then
  72.         Err := LoadScrap;
  73.     If Err = NoErr then
  74.       Begin
  75.         TheResource := TheScrap^.ScrapHandle;
  76.         Err := HandToHand(TheResource);
  77.         If Err = NoErr then
  78.           Begin
  79.         AddResource(TheResource, TheResType, TheResID, '');
  80.         Err := ResError;
  81.         If Err = NoErr then
  82.           Begin
  83.             SetResAttrs(TheResource, BitOr(GetResAttrs(TheResource), ResPurgeable));
  84.             UpdateResFile(CurResFile);
  85.             Err := ResError;
  86.             HPurge(TheResource)
  87.           End
  88.         else
  89.             DisposHandle(TheResource)
  90.           End {If}
  91.       End {If};
  92.     If Err <> NoErr then
  93.         ReturnError(Err);
  94.     If WasOnDisk then
  95.         Err := UnloadScrap
  96.       End {TheProc};
  97.  
  98. Begin {SaveScrap}
  99.   { dummy mainline }
  100. End {SaveScrap}.
  101.